Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/ISSUE02/TPACK/TPACK.ZIP/BITBOX.PAS

Pascal/Delphi Source File | 1995-06-01 | 15.1 KB | 539 lines

{------------------------------------------------------------------------------}
{UNREGISTERED VERSION (6/1/95) PLEASE REDISTRIBUTE IN tPACK.ZIP!
 This revision does not contain everything, nor are the exciting
 DataSetReporter and ExtendedMenu[Item] components included.
 Use SWREG#5906 to receive these, icons and a help file for $130.
 You must register when using this code in a business application!
 You'll receive a license to use this code in up to 50 copies of
 any app you write. In turn you will get responsive e-mail
 tech support and enhancements till I run out of registrations
 or suggestions. Meanwhile.. enjoy the code. Bye! I'll make more.
 {(C)'1995 Michael/Ax-Systems, 71560,[e-mail]}
{------------------------------------------------------------------------------}

unit Bitbox;

{The SECOND implementation
does multiple columns and rows smartly.
understands text better.
resizes imperfectly still}

{BitBox like Toolbars anyone? just kidding}

{THE POINT:  To create checkbox group components that will take a byte or word
and provide dynamically sized boxes containing selected items from a universe
of 8 or 16 choices. Allowing the user to check/set bits via a form.}

{this unit takes advantage of delphi's small set implementation, which works
in bytes and words for sets with less than 9/17 members respectively.}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DB, DBTables, StdCtrls;

type
  {define the word compatible set}
  T16Bits = (Bit0,Bit1,Bit2,Bit3,Bit4,Bit5,Bit6,Bit7
            ,Bit8,Bit9,BitA,BitB,BitC,BitD,BitE,BitF);
  TWordSet = Set of T16Bits;
  TWord = Record
    x:Word;
    end;

  TBoxOrientation = (boxVertical,boxHorizontal);

  {define a common groupbox for byte and word use}
  TBitBox = class(TGroupBox)
  private
    fMembers: TWordSet;
    fMask: TWordSet;
    fCaptions: TStringList;
    fHints: TStringList;
    fOnChange: TNotifyEvent;
    fReadOnly: Boolean;

    fBoxOrientation: TBoxOrientation;
    fFromLeft: Byte;
    fFromRight: Byte;
    fColumns: Byte;
    fMinTextWidth:Byte;
    fMaxTextWidth:Integer;
    fFromTop:Byte;
    fRowHeight:Byte;
    fColumnSpacing:Byte;

    procedure ChangeSelected(Sender:TObject); virtual;
  protected
    function GetMember:Word;
    procedure SetMember(Value:Word);
    procedure SetMembers(Value:TWordSet);
    procedure SetMask(Value:TWordSet);
    procedure SetCaptions(Value:TStringList);
    procedure SetHints(Value:TStringList);
    function GetMaxTextWidth:Integer;
    procedure SetColumns(Value:Byte);
    procedure SetFromTop(Value:Byte);
    procedure SetRowHeight(Value:Byte);
    procedure SetMinTextWidth(Value:Byte);
    procedure SetMaxTextWidth(Value:Integer);
    procedure SetColumnSpacing(Value:Byte);
    procedure SetBoxOrientation(Value:TBoxOrientation);
    procedure InitBox;
  public
    constructor Create(aOwner:TComponent); Override;
    destructor Destroy; Override;
    procedure Loaded; Override;
    procedure Init; {[re]creates checkboxes from fUniverse/fMembers}
    procedure UpdateAll;
    procedure Update(Bit:T16Bits;aChecked:Boolean;aCaption:String); {updates chekbox}
  published
    property Numeric:  Word read GetMember write SetMember;
    property Possible: TWordSet read fMask write SetMask;
    property Selected: TWordSet read fMembers write SetMembers;
    property ReadOnly: Boolean read fReadOnly write fReadOnly default False;
    property Captions: TStringList read fCaptions write SetCaptions;
    property Hints:    TStringList read fHints write SetHints;
    property OnChange: TNotifyEvent read fOnChange write fOnChange;

    property BoxOrientation: TBoxOrientation read fBoxOrientation write SetBoxOrientation
    {$IFDEF START_HORIZONTALLY}
      default boxHorizontal;
    {$ELSE}
      default boxVertical;
    {$ENDIF}
    property Columns: Byte read fColumns write SetColumns
    {$IFDEF START_HORIZONTALLY}
      default 0;
    {$ELSE}
      default 2;
    {$ENDIF}
    property FromTop: Byte read fFromTop write fFromTop default 20;
    property FromLeft: Byte read fFromLeft write fFromLeft default 10;
    property FromRight: Byte read fFromRight write fFromRight default 5;
    property RowHeight: Byte read fRowHeight write SetRowHeight default 20;
    property ColumnSpacing:Byte read fColumnSpacing write SetColumnSpacing default 10;
    property MinTextWidth:Byte read fMinTextWidth write SetMinTextWidth default 16;
    property MaxTextWidth:Integer read GetMaxTextWidth write SetMaxTextWidth;
    end;

  TdbBitBox = class(TBitBox)
  private
    FDataLink: TFieldDataLink;
    procedure DataChange(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure ChangeSelected(Sender:TObject); override;
    procedure UpdateData(Sender: TObject);
    procedure EditingChange(Sender: TObject);
  protected
    function GetReadOnly: Boolean;
    procedure SetReadOnly(Value: Boolean);
    procedure Notification(AComponent: TComponent;
      Operation: TOperation); override;
  public
    constructor Create(aOwner:TComponent); Override;
    destructor Destroy; Override;
    property Field: TField read GetField;
  published
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    end;


implementation

{------------------------------------------------------------------------------}
{ CREATE, PREPARE AND DISPOSE OF THE COMPONENT                                 }
{------------------------------------------------------------------------------}

constructor TBitBox.Create(aOwner:TComponent);
var
  Bit: T16Bits;
begin
  inherited Create(aOwner);
  fColumnSpacing:=10;
  fFromTop:=20;
  fFromLeft:=10;
  fFromRight:=5;
  fRowHeight:=20;
  fMinTextWidth:=13;
  {$IFDEF START_HORIZONTALLY}
    fBoxOrientation:=boxHorizontal;
    fColumns:=0;
  {$ELSE}
    fBoxOrientation:=boxVertical;
    fMaxTextWidth:=100;
    fColumns:=2;
  {$ENDIF}
  fCaptions:=TStringList.Create;
  fHints:=TStringList.Create;
  for Bit:= Bit0 to BitF do begin
    Include(fMask,Bit);
    fCaptions.Add('(Bit'+inttoStr(ord(bit))+')');
    fHints.Add('(Bit'+inttoStr(ord(bit))+')');
    end;
end;

procedure TBitBox.Loaded;
begin
  inherited Loaded;
  InitBox;
end;

destructor TBitBox.Destroy;
begin
  fCaptions.Free;
  fCaptions:=nil;
  fHints.Free;
  fHints:=nil;
  inherited Destroy;
end;

{------------------------------------------------------------------------------}
{ GET AND SET THE COMPONENT SPECIFIC PROPERTIES                                }
{------------------------------------------------------------------------------}

function TBitBox.GetMember:Word;
var
  s:TWordSet;
begin
  s:=fMembers;
  result:=tWord(s).x;
end;

procedure TBitBox.SetMember(Value:Word);
var
  s:TWordSet;
begin
  s:=TWordSet(Value);
  SetMembers(s);
end;

procedure TBitBox.SetMembers(Value:TWordSet);
begin
  if fMembers<>Value then begin
    fMembers:=Value;
    UpdateAll;
    end;
end;

procedure TBitBox.SetMask(Value:TWordSet);
begin
  if fMask<>Value then begin
    fMask:=Value;
    init;
    end;
end;

procedure TBitBox.SetCaptions(Value:TStringList);
begin
  if fCaptions<>Value then begin {wow}
    fCaptions.Assign(Value);
    UpdateAll;
    end;
end;

procedure TBitBox.SetHints(Value:TStringList);
begin
  if fHints<>Value then begin
    fHints.Assign(Value);
    UpdateAll;
    end;
end;

procedure TBitBox.SetColumns(Value:Byte);
begin
  if fColumns<>Value then begin
    fColumns:=Value;
    Init;
    end;
end;

procedure TBitBox.SetRowHeight(Value:Byte);
begin
  if fRowHeight<>Value then begin
    fRowHeight:=Value;
    Init;
    end;
end;

procedure TBitBox.SetBoxOrientation(Value:TBoxOrientation);
begin
  if fBoxOrientation<>Value then begin
    fBoxOrientation:=Value;
    Init;
    end;
end;

procedure TBitBox.SetMinTextWidth(Value:Byte);
begin
  if fMinTextWidth<>Value then begin
    fMinTextWidth:=Value;
    Init;
    end;
end;

function TBitBox.GetMaxTextWidth:Integer;
begin
  if fMaxTextWidth<fMinTextWidth then
    fMaxTextWidth:=fMinTextWidth;
  Result:= fMaxTextWidth;
end;

procedure TBitBox.SetMaxTextWidth(Value:Integer);
begin
  if fMaxTextWidth<>Value then begin
    fMaxTextWidth:=Value;
    Init;
    end;
end;

procedure TBitBox.SetColumnSpacing(Value:Byte);
begin
  if fColumnSpacing<>Value then begin
    fColumnSpacing:=Value;
    Init;
    end;
end;

procedure TBitBox.SetFromTop(Value:Byte);
begin
  if fFromTop<>Value then begin
    fFromTop:=Value;
    Init;
    end;
end;

{------------------------------------------------------------------------------}
{ INITIALIZE AND UPDATE ALL OR ONE CHECKBOX IN THE GROUP                       }
{------------------------------------------------------------------------------}

procedure TBitBox.Init;
begin
  if not (csLoading in ComponentState) then
    InitBox;
end;

procedure TBitBox.InitBox;
var
  Cols,i,n:integer;
  Bit:T16Bits;
  c:TCheckBox;
  col,row,percol:byte;
begin
  n:=ControlCount-1;
  if n>-1 then
    for i:=0 to n do
      Controls[0].Free;     {free all owned controls. really.}
  n:=0;
  for bit:= Bit0 to BitF do {step and count how many we'll be making}
    if bit in fMask then
      n:=n+1;
  if n=0 then {nothing to do} {shrink?}
    exit;
  Cols:=fColumns;
  if Cols<=0 then
    Cols:=1;
  if (fBoxOrientation=boxHorizontal) and (fColumns<2) then
    Cols:=n;  {adjust to all accross.}
  percol:=n div Cols;          {figure out how many rows that'll be}
  if (n mod Cols) >0 then  {adjust to get 2 rows for 3 items in 2 columns}
    percol:=percol+1;
  i:=FromLeft+FromRight+Cols*(fColumnSpacing+MaxTextWidth);
  if Width<i then
    Width:=i;
  row:=0;
  col:=0;
  for bit:= Bit0 to BitF do
    if bit in fMask then begin  {make new child controls}
      c:=TCheckBox.Create(self);
      with c do begin
        Checked:= bit in fMembers;
        end;
      with c do begin
        Tag:=ord(bit);
        Caption:= fCaptions.Strings[Tag];
        Hint:= fHints.Strings[Tag];
        Parent:=Self;
        OnClick:=ChangeSelected;
        Left:=FromLeft+Col*(fColumnSpacing+fMaxTextWidth);
        Width:=MaxTextWidth;
        Top:=fFromTop+(Row*fRowHeight);
        if fBoxOrientation=boxVertical then begin
          Row:=row+1;
          if Row=PerCol then begin
            Row:=0;
            Col:=Col+1;
            end;
          end
        else begin
          Col:=Col+1;
          if Cols=Cols then begin
            Col:=0;
            Row:=Row+1;
            end;
          end;
        end;
      end;
  if Height<(fRowHeight*(PerCol+1)) then;
    Height:=(fRowHeight*(PerCol+1));
end;

procedure TBitBox.UpdateAll;
var
  Bit:T16Bits;
begin
  for Bit:= Bit0 to BitF do
    if Bit in fMask then
      Update(Bit,Bit in fMembers,fCaptions.Strings[ord(Bit)])
end;

procedure TBitBox.Update(Bit:T16Bits;aChecked:Boolean;aCaption:String);
var
  i,n:integer;
begin
  n:=ControlCount-1;
  if n>-1 then
    for i:=0 to n do
      if Controls[i].Tag=ord(Bit) then
        with TCheckBox(Controls[i]) do begin
          Caption:=aCaption;
          Checked:=aChecked;
          break;
          end;
end;

{------------------------------------------------------------------------------}
{ PROCS FOR CUSTOM EVENTS                                                      }
{------------------------------------------------------------------------------}

procedure TBitBox.ChangeSelected(Sender:TObject);
var
  c:TCheckBox;
  b:T16Bits;
begin
  c:=TCheckBox(Sender);
  b:=T16Bits(c.Tag); {remember, we're using the tag to hold the bit value of the checkbox}
  if c.Checked then
    fMembers:=fMembers+[b]
  else
    fMembers:=fMembers-[b];
  if assigned(fOnChange) then
    fOnchange(Sender);
end;

{------------------------------------------------------------------------------}
{ PROCS TO ERECT THE DATASOURCE CONNECTED COMPONENT                            }
{------------------------------------------------------------------------------}

constructor TdbBitBox.Create(aOwner:TComponent);
begin
  inherited Create(aOwner);
  inherited ReadOnly := True;
  FDataLink:= TFieldDataLink.Create;
  FDataLink.OnDataChange:= DataChange;
  FDataLink.Control := Self;
  FDataLink.OnEditingChange := EditingChange;
  FDataLink.OnUpdateData := UpdateData;
end;

destructor TdbBitBox.Destroy;
begin
  FDataLink.Free;
  FDataLink := nil;
  fCaptions.Free;
  fCaptions:=nil;
  inherited Destroy;
end;

procedure TdbBitBox.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (FDataLink <> nil) and
    (AComponent = DataSource) then DataSource := nil;
end;

{------------------------------------------------------------------------------}
{ PLUMBING AND READ-ONLY                                                       }
{------------------------------------------------------------------------------}

function TdbBitBox.GetDataSource: TDataSource;
begin
  Result := FDataLink.DataSource;
end;

procedure TdbBitBox.SetDataSource(Value: TDataSource);
begin
  FDataLink.DataSource := Value;
end;

function TdbBitBox.GetDataField: string;
begin
  Result := FDataLink.FieldName;
end;

procedure TdbBitBox.SetDataField(const Value: string);
begin
  FDataLink.FieldName := Value;
end;

function TdbBitBox.GetField: TField;
begin
  Result := FDataLink.Field;
end;

function TdbBitBox.GetReadOnly: Boolean;
begin
  Result := FDataLink.ReadOnly;
end;

procedure TdbBitBox.SetReadOnly(Value: Boolean);
begin
  FDataLink.ReadOnly := Value;
end;

{------------------------------------------------------------------------------}
{                                                                              }
{------------------------------------------------------------------------------}

procedure TdbBitBox.DataChange(Sender: TObject);
begin
  if FDataLink.Field <> nil then
    Numeric := FDataLink.Field.AsInteger
  else
    if csDesigning in ComponentState then Numeric := 0;
end;

procedure TdbBitBox.ChangeSelected(Sender:TObject);
begin
  inherited ChangeSelected(Sender);
  if FDataLink.Field <> nil then
    if not (csDesigning in ComponentState) then
      UpdateData(Sender);
end;

procedure TdbBitBox.EditingChange(Sender: TObject);
begin
  inherited ReadOnly := not FDataLink.Editing;
end;

procedure TdbBitBox.UpdateData(Sender: TObject);
begin
  if Numeric<>FDataLink.Field.AsInteger then
    if FDataLink.Edit then
      FDataLink.Field.AsInteger:= Numeric;
end;


{------------------------------------------------------------------------------}
{                                                                              }
{------------------------------------------------------------------------------}

end.